home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / PROGRAM / CHF.ARJ / CHF.PRG < prev   
Text File  |  1991-10-02  |  4KB  |  154 lines
  1. /******
  2. PROGRAM: CHF.PRG 
  3. AUTHOR:  Steve Kolterman
  4. Date:    03/09/91
  5. Version: Clipper 5.0 (CLIPPER CHF/N/M/A)
  6. Notes:  This program will produce a header file containing #define
  7. directives for each field in a database.  The values assigned are the 
  8. same as their position in the database structure.
  9. Modified : by Tom Walden, to allow the user to add an optional prefix to the
  10. DEFINE declarations for uniqueness.*****/
  11.  
  12. #include "Chf.ch"     //Make sure you have this file also.
  13. MEMVAR GetList
  14.  
  15. STATIC err_cume:=0  // Error counter
  16. STATIC cSymbol :=' '  //Prefix
  17.  
  18. //STATIC gdirec:="\clipper5\develop\data\WKSAMP.DBF"
  19. //LOCAL dbfch := gdirec+"wksamp.dbf"
  20.  
  21.  
  22. FUNCTION MakeChfile(dbff,ch_name)  //the Shell
  23.  
  24.  LOCAL fn_array, w_area:= SELECT(),path
  25.  LOCAL oldcurs:=SETCURSOR(SC_NONE)
  26.  SET SCORE OFF
  27.  SET CURSOR ON
  28.  
  29. IF dbff<> NIL .AND. FILE(DBF_NAME)
  30. // NEW CODE STARTS HERE
  31.     BEEP2
  32.     SETCOLOR('r/w')
  33.     CLEAR SCREEN
  34.     SETCOLOR('gr+/b')
  35.     @8,18 clear to 14,61
  36.     @8,18 to 14,61 DOUBLE
  37.     @10,22 Say 'Character prefix for field name:';
  38.            GET cSymbol PICT'@'
  39.     @12,22 SAY '(Examples: _m__^,or none)'
  40.     READ
  41.     cSymbol:=trim(cSymbol)
  42.        //End of new code
  43.  
  44.        fn_array:=DIRECTORY(IF(WILDCARD,dbff,DBF_NAME))
  45.  
  46.        ch_name:=IF(fn_array==NIL.OR. LEN(fn_array)>1,;
  47.        NIL,ch_name)
  48.  
  49. IF fn_array<>NIL
  50.     path:=IF("\"$dbff.OR.":\"$dbff,;
  51.         LEFT(dbff,RAT("\",dbff)),;
  52.     IF(":"$dbff,LEFT(dbff,RAT(":",dbff)),""))
  53.       AEVAL(fn_array,;
  54.         {|x,y| WriteCh(path,fn_array[y][F_NAME],ch_name)})
  55.         ENDIF
  56. ENDIF
  57.  
  58.  
  59. SELECT(w_area)
  60. IF NIL_COND .OR. err_cume>0
  61.   QOUT("NEED A VALID .DBF SPEC")
  62.  END
  63.  SETCURSOR(oldcurs)
  64. @18,37 SAY 'DONE!!'    //NEW CODE
  65. BEEP3
  66. RETURN(err_cume)
  67.  
  68. FUNCTION WriteCh(path,dbffile,ch_name)  //THE AUTHOR
  69.   LOCAL handle,dummy:={}
  70.  
  71.  IF(handle:=FCREATE(IF(ch_name==NIL,(CH_NAME),;
  72.       ch_name+".CH"))) <> F_ERROR
  73.     USE (path+dbffile)NEW
  74.     ASIZE(dummy,FCOUNT())
  75.     FWRITE(handle,HEADLINE+TYPELINE)
  76.     AEVAL(dummy,{|x,y|FWRITE(handle,BUFFER)})
  77.     FWRITE(handle,FOOTLINE+CREDIT+COPYRITE)
  78.     USE
  79.   ENDIF
  80.  
  81. IF handle==-1;err_cume++;END
  82.     FCLOSE(handle)
  83. RETURN(handle)
  84.  
  85.  
  86. /*SK_Field.prg
  87.   The SK Field Functions. Pass'em either a field name or an ordinal.dbf
  88.   position. We don't care.
  89. */
  90.  
  91. #define FGV fieldget(var)
  92. #define VTFGV valtype((FGV))
  93. #define FBV FieldBlock(var)
  94. #define FBFNV FieldBlock(fieldname(var))
  95. #define EVFBV Eval((FBV))
  96. #define VTFV valtype(EVFBV)
  97. #define VTV valtype(var)
  98. #define TNUM IF(!(VTV)$"NC",NIL,IF((VTV)=="N",(VTFGV),(VTFV)))
  99. #define TCHR IF(!(VTV)$"NC",NIL,IF((VTV)=="N",(FGV),(EVFBV)))
  100. #define DBS_NAME1
  101. #translate ATRIM(<x>)=>LTRIM(TRIM(<x>))
  102.  
  103. /***
  104. This series returns character or logical values.
  105. ****/
  106.  
  107. FUNCTION FieldVal(var)
  108. RETURN(TCHR)
  109.  
  110. FUNCTION FieldType(var)
  111. RETURN(TNUM)
  112.  
  113. FUNCTION FieldPlace(var,value)
  114. RETURN EVAL(IF((VTV)=="N",(FBFNV),(FBV)),value)
  115.  
  116. FUNCTION FieldExist(var)
  117. RETURN IF((VTV)=="N",(FBFNV<>NIL),;
  118.   IF((VTV)=="C",(FBV<>NIL),.F.))
  119.  
  120. /***
  121. THIS SERIES RETURNS NUMERIC VALUES
  122. ***/
  123.  
  124. FUNCTION FieldLen(var)
  125. RETURN IF((TNUM)=="D",LEN(DTOC((TCHR))),;
  126. IF((TNUM)=="L",1,;
  127. IF((TNUM)=="M",10,;
  128. IF((TNUM)=="C",LEN((TCHR)),;
  129. IF((TNUM)=="N",LEN(STR((TCHR))),-1)))))
  130.  
  131. FUNCTION FieldValLen(var)
  132. RETURN IF((TNUM)=="D",LEN(DTOC((TCHR))),;
  133. IF((TNUM)=="L",1,;
  134. IF((TNUM)=="M",LEN(ATRIM((TCHR))),;
  135. IF((TNUM)=="C",LEN(ATRIM((TCHR))),;
  136. IF((TNUM)=="N",LEN(ATRIM(STR((TCHR)))),-1)))))
  137.  
  138. FUNCTION FieldDec(var)
  139. RETURN IF((TNUM)<>"N",-1,;
  140.  IF((TNUM)=="N".AND."."$STR((TCHR)),;
  141.  LEN(STR((TCHR)))-AT(".",STR((TCHR))),0))
  142.  
  143. /*HATED TO WRITE IT THIS WAY, BUT THERE'S NO OTHER WAY TO WRITE IT ..
  144.   EXCEPT C OR .ASM IN THE CASE OF A 100 FIELD DBF. YOU USE MORE THAN 1300
  145.   BYTES OF MEM PLUS OVERHEAD FOR A CALL THAT MIGHT RETURN AS LITTLE AS 1 BYTE.*/
  146.  
  147. FUNCTION FieldNum(var)
  148.  LOCAL bdsarray:=Dbstruct()
  149.  RETURN IF((VTV)=="C".AND.(FBV<>NIL),;
  150.     ASCAN(dbsarrry,{|e| UPPER(var)==e[DBS_NAME]}),-1)
  151.  
  152. /*EOF:CHF.PRG*/
  153.  
  154.